perm filename PDTBAS.SAI[PIC,HE] blob
sn#430349 filedate 1979-04-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00010 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY PPROP,PREG,PVAL,PASREG,DSEARCH,PREGION
C00004 00003 ! Procedure to return a string identifying a STRING ITEMVAR
C00006 00004 ! Procedure to return a "value" of an itemvar given its property
C00014 00005 [4] BEGIN "SAT"
C00015 00006 ! Procedure to print Associations between regions (that are in REGLST) according
C00018 00007 [3] BEGIN
C00020 00008 [6] IF (OBJECT IN REGLST) THEN BEGIN
C00021 00009 ! PROCEDURE RETURN ALL THE PROPERTIES OF A REGION.
C00022 00010 REQUIRE UNSTACK!DELIMITERS
C00023 ENDMK
C⊗;
ENTRY PPROP,PREG,PVAL,PASREG,DSEARCH,PREGION;
BEGIN "PDTBAS"
REQUIRE "BUFDEC.SAI" SOURCE!FILE;
SOURCE!V(EXTITM);
REQUIRE "⊂⊃<>" DELIMITERS;
! This module is a module of string returning
procedures that is used to look at a data base
created by DATBAS.SAI[A640AI00] (another module);
! Procedure to return the name of a property.
The resulting value will be left justified in
a string of length 15. And if no such property
exists then 15 blanks is returned. The last two characters
are guaranteed to be blanks.;
simple INTERNAL STRING PROCEDURE PPROP(STRING ITEMVAR PROPERTY);
BEGIN "PPROP"
INTEGER PROP,LN,K;
STRING STR,SDUM;
SDUM←DATUM(PROPERTY);
STR←" ";
IF (LN←LENGTH(SDUM))>13 THEN RETURN(SDUM[1 TO 13]&" ");
RETURN(SDUM&STR[1 FOR (15-LN)]);
END "PPROP";
! Procedure to return a string identifying a STRING ITEMVAR
(usually a region) according to the value of NMSW.
NMSW RESULT
0 Just its number left justified in 4 blanks (props)
1 Just its name at most 13 chars. left justified in 15 blanks (datum)
2 Number and name left justified in 15 blanks with last 2 chars.
as guaranteed blanks ([<number>]<1 blank><name, 13 chars at most><2
blanks at least>)
other A string of 15 blanks;
simple INTERNAL STRING PROCEDURE PREG(ITEMVAR ITMVAR;INTEGER NMSW);
BEGIN "PREG"
INTEGER LN;
STRING STR,SDUM;
STRING ITEMVAR STRVAR;
STR←" ";
STRVAR←ITMVAR;
IF 0≤NMSW≤2 THEN CASE NMSW OF BEGIN
[0] BEGIN
LN←LENGTH(SDUM←CVS(PROPS(STRVAR)));
RETURN(SDUM&STR[1 FOR (4-LN)]);
END;
[1] LN←LENGTH(SDUM←DATUM(STRVAR));
[2] LN←LENGTH(SDUM←"["&CVS(PROPS(STRVAR))&"] "&DATUM(STRVAR))
END
ELSE RETURN(STR);
IF LN>13 THEN RETURN(SDUM[1 TO 13]&" ");
RETURN(SDUM&STR[1 FOR (15-LN)]);
END "PREG";
! Procedure to return a "value" of an itemvar given its property
type, and NMSW switch of PREG.
Returns null if property is bad. But it will fail if you give
it a bad value. Lenght of string is defined by PREG if it is
a string type value. Otherwise it could return any size string
it needs.;
INTERNAL STRING PROCEDURE PVAL(STRING ITEMVAR PROPERTY,VALUE;INTEGER NMSW);
BEGIN "PVAL"
INTEGER FLG,K,TAB1,TAB2,TAB3,TAB4,DUM,NUMOUT,I,j,TYPE;
REAL ITEMVAR RELVAR;
INTEGER ITEMVAR INTVAR;
INTEGER ARRAY ITEMVAR ARRVAR;
RECORD!POINTER(ANY!CLASS) ITEMVAR RPIV;
RECORD!POINTER(DRR) DRREC;
RECORD!POINTER(RRVAL) RRREC;
STRING ITEMVAR STRVAR;
STRING STR,SDUM,OSTR,TABS;
INTEGER ARRAY VAL[1:2];
DEFINE REALOUT=⊂DATUM(RELVAR←VALUE)⊃;
DEFINE STROUT=⊂DATUM(STRVAR←VALUE)⊃;
DEFINE BROCKET(NUM1,NUM2,NUM3,NUM4)=⊂"<"&CVS(NUM1)&"*"&CVS(NUM2)&"><"&
CVS(NUM3)&"*"&CVS(NUM4)&">"⊃;
simple INTEGER PROCEDURE UNPACK(INTEGER ITEMVAR VALUE;REFERENCE INTEGER ARRAY VAL);
BEGIN
INTEGER DUM;
DUM←DATUM(VALUE);
VAL[1]←SLHALF(DUM);
VAL[2]←SRHALF(DUM);
END;
simple STRING PROCEDURE REAL!2(ITEMVAR VALUE);
BEGIN
UNPACK(VALUE,VAL);
RETURN(CVF(VAL[1]/10)&" (STD.="&CVF(VAL[2]/10)&")");
END;
simple STRING PROCEDURE VEC!ARR;
BEGIN
ARRVAR←VALUE;
OSTR←tab&CVS((DUM←ARRINFO(DATUM(ARRVAR),0))-2)&tab&BROCKET(SLHALF(<DATUM(ARRVAR)[1]>),
SRHALF(<DATUM(ARRVAR)[1]>),SLHALF(<DATUM(ARRVAR)[2]>),SRHALF(<DATUM(ARRVAR)[2]>))&CRLF;
STR←CVS(SLHALF(<DATUM(ARRVAR)[3]>));
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[3]>));
OSTR←OSTR&tab&"("&TABS[1 TO TAB1-LENGTH(STR)]&STR&","&SDUM;
NUMOUT←1;
FOR I←4 THRU DUM DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(SLHALF(<DATUM(ARRVAR)[I]>));
IF NUMOUT>5 THEN BEGIN NUMOUT←1; OSTR←OSTR&CRLF&tab&TABS[1 TO TAB2-LENGTH(STR)] END
ELSE OSTR←OSTR&TABS[1 TO TAB3-LENGTH(SDUM)-LENGTH(STR)];
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[I]>));
OSTR←OSTR&STR&","&SDUM;
END;
RETURN(CRLF&OSTR&" )"&CRLF);
END;
TAB1←4; TAB2←TAB1+1; TAB3←9; TAB4←30;
TABS←" ";
FLG←0;
FOR K←1 THRU 19 DO IF PROPERTY=DPROLST[K] THEN DONE;
if k≠2 AND k≠11 AND k≠12 AND k≠4 then
BEGIN
TYPE←PROPS(PROPERTY);
IF FLG THEN RETURN(NULL);
CASE TYPE OF
BEGIN
;
RETURN(STROUT);
BEGIN "2 INT"
if k≤19 then return(real!2(value));
UNPACK(VALUE,VAL);
RETURN(CVS(VAL[1])&" "&CVS(VAL[2]));
END "2 INT";
BEGIN "3 INT"
DUM←DATUM(INTVAR←VALUE);
RETURN(CVS(SUN1ST(DUM))&" "&CVS(SUN2ND(DUM))&" "&CVS(SUN3RD(DUM)));
END;
BEGIN "REAL"
RETURN(CVF(REALOUT));
END "REAL";
BEGIN "VECTOR LIST"
RETURN(VEC!ARR);
END "VECTOR LIST";
BEGIN "INTEGER ARRAY"
ARRVAR←VALUE;
OSTR←tab&CVS((DUM←ARRINFO(DATUM(ARRVAR),0)));
NUMOUT←5;
FOR I←1 THRU DUM DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(DATUM(ARRVAR)[I]);
IF NUMOUT>5 THEN BEGIN NUMOUT←1; OSTR←OSTR&CRLF&tab&TABS[1 TO TAB2-LENGTH(STR)] END
ELSE OSTR←OSTR&TABS[1 TO TAB3-LENGTH(STR)];
OSTR←OSTR&STR;
END;
RETURN(CRLF&OSTR&" )"&CRLF);
END "INTEGER ARRAY";
BEGIN "2 PACKED INTEGER ARRAY"
ARRVAR←VALUE;
OSTR←tab&CVS((DUM←ARRINFO(DATUM(ARRVAR),0)))&CRLF;
STR←CVS(SLHALF(<DATUM(ARRVAR)[1]>));
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[1]>));
OSTR←OSTR&tab&"("&TABS[1 TO TAB1-LENGTH(STR)]&STR&","&SDUM;
NUMOUT←1;
FOR I←2 THRU DUM DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(SLHALF(<DATUM(ARRVAR)[I]>));
IF NUMOUT>5 THEN BEGIN NUMOUT←1; OSTR←OSTR&CRLF&tab&TABS[1 TO TAB2-LENGTH(STR)] END
ELSE OSTR←OSTR&TABS[1 TO TAB3-LENGTH(SDUM)-LENGTH(STR)];
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[I]>));
OSTR←OSTR&STR&","&SDUM;
END;
RETURN(CRLF&OSTR&" )"&CRLF);
END "2 PACKED INTEGER ARRAY";
RETURN(PREG(VALUE,NMSW));
begin "real array"
real array itemvar raiv;
raiv←value;
ostr←crlf&tab&cvs(dum←arrinfo(datum(raiv),2))&tab&cvs(zilch←arrinfo(datum(raiv),4));
for i←1 thru dum do
begin
ostr←ostr&crlf&tab;
for j←1 thru zilch do
ostr←ostr&cvf(datum(raiv)[i,j])&tab;
end;
return(ostr&crlf);
end "real array";
BEGIN "RECORD TYPE"
RPIV←VALUE;
DRREC←DATUM(RPIV);
RETURN("REG: "&PREG(DRR:REG[DRREC],NMSW)&" VAL1: "&CVS(DRR:V1[DRREC])&" VAL2: "&CVS(DRR:V2[DRREC]));
END "RECORD TYPE";
BEGIN "RECORD TYPE 2"
RPIV←VALUE;
RRREC←DATUM(RPIV);
RETURN("REG1: "&PREG(RRVAL:REG1[RRREC],NMSW)&" REG1: "&PREG(RRVAL:REG2[RRREC],NMSW)&" VAL: "&CVF(RRVAL:V1[RRREC]));
END "RECORD TYPE 2";
END;
END
ELSE CASE K OF BEGIN
[2] RETURN(CVF(REALOUT*100)&" %"); ! SIZE;
[4] BEGIN "SAT"
UNPACK(VALUE,VAL);
RETURN(CVF(VAL[1]/(2↑10-1))&" (STD.="&
CVF(VAL[2]/(2↑10-1))&")");
END "SAT";
[11] BEGIN "MDERIVE"
INTVAR←VALUE;
DUM←DATUM(INTVAR);
RETURN("PARM: "&CVS(SUN1ST(DUM))&tab&"UPTHR: "&CVS(SUN2ND(DUM))&tab&"LWTHR: "&CVS(SUN3RD(DUM)));
END "MDERIVE";
[12] BEGIN "PICSIZ"
UNPACK(VALUE,VAL);
RETURN(CVS(VAL[1])&" ROWS BY "&CVS(VAL[2])&" COLUMNS");
END "PICSIZ"
END;
END "PVAL";
! Procedure to print Associations between regions (that are in REGLST) according
to PSW and NMSW, where NMSW is defined the same as it is
for PREG.
PSW RESULT
1 ALL PROPERTY⊗ANY≡ANY
2 ALL ANY⊗OBJECT≡ANY
3 ALL ANY⊗ANY≡VALUE
4 ALL PROPERTY⊗OBJECT≡ANY
5 ALL PROPERTY⊗ANY≡VALUE
6 ALL ANY⊗OBJECT≡VALUE
7 ALL PROPERTY⊗OBJECT≡VALUE
other NULL STRING RETURNED
All strings in a CRLF except for PSW="other".;
INTERNAL PROCEDURE PASREG(ITEMVAR PROPERTY,OBJECT,VALUE;REFERENCE LIST REGLST;INTEGER PSW,NMSW,INDENT);
BEGIN "PASREG"
ITEMVAR PRO,OBJ,VAL;
INTEGER J,LNGTH;
STRING STR,SDUM,BLANKS,DITTO,STMP,SINDENT;
simple STRING PROCEDURE PRIN!MODIF;
IF PROPS(PRO)=8 THEN RETURN(NULL)
ELSE RETURN(CASE PROPS(VAL) OF (NULL,"<LESS>","<GREATER>",NULL,"<APPROX>"));
simple PROCEDURE PR!FIRST;
PRINT(STR←SINDENT,PPROP(PRO),"OF ",PREG(OBJ,NMSW),"IS ",
PRIN!MODIF,PVAL(PRO,VAL,NMSW),CRLF);
DITTO←" "" ";
BLANKS←" ";
SINDENT←" "[1 FOR INDENT];
SDUM←STMP←STR←NULL;
LNGTH←J←0;
IF 0<PSW<8 THEN
CASE PSW OF
BEGIN
[1] BEGIN
PRO←PROPERTY;
FOREACH OBJ,VAL|PRO⊗OBJ≡VAL DO
IF (OBJ IN REGLST) THEN BEGIN
IF (J←J+1)=1 THEN
PR!FIRST
ELSE PRINT(STR←SINDENT,DITTO,"OF ",PREG(OBJ,NMSW),"IS ",
PRIN!MODIF,PVAL(PRO,VAL,NMSW),CRLF);
END;
END;
[2] IF (OBJECT IN REGLST) THEN BEGIN
OBJ←OBJECT;
FOREACH PRO,VAL|PRO⊗OBJ≡VAL DO
IF (J←J+1)=1 THEN
BEGIN
IF LENGTH(SDUM←PREG(OBJ,NMSW))≠15 THEN DITTO←" "" ";
PRINT(STR←SINDENT,PPROP(PRO),"OF ",SDUM,PRIN!MODIF,PVAL(PRO,VAL,NMSW),CRLF);
END
ELSE PRINT(STR←SINDENT,PPROP(PRO),"OF ",DITTO,"IS ",
PRIN!MODIF,PVAL(PRO,VAL,NMSW),CRLF);
END ;
[3] BEGIN
VAL←VALUE;
FOREACH PRO,OBJ| PRO⊗OBJ≡VAL DO
IF (OBJ IN REGLST) THEN
BEGIN
IF (J←J+1)=1 THEN
PR!FIRST
ELSE PRINT(STR←SINDENT,PPROP(PRO),"OF ",PREG(OBJ,NMSW),
"IS ",DITTO,CRLF);
END;
END;
[4] IF (OBJECT IN REGLST) THEN BEGIN
PRO←PROPERTY;
OBJ←OBJECT;
IF NMSW THEN DITTO←BLANKS ELSE DITTO←" ";
FOREACH VAL|PRO⊗OBJ≡VAL DO
BEGIN
IF (J←J+1)=1 THEN
PRINT(SDUM←SINDENT,PPROP(PRO),"OF ",PREG(OBJ,NMSW),"IS ");
STMP←PRIN!MODIF&PVAL(PRO,VAL,NMSW);
IF (LNGTH←LNGTH+LENGTH(STMP))>15 AND J>1 THEN
BEGIN
PRINT(CRLF,SINDENT,BLANKS,DITTO,BLANKS[1 FOR 10],STMP);
LNGTH←LENGTH(STMP);
END
ELSE PRINT(STMP);
END;
IF J>0 THEN PRINT(CRLF);
END ;
[5] BEGIN
PRO←PROPERTY;
VAL←VALUE;
FOREACH OBJ|PRO⊗OBJ≡VAL DO
IF (OBJ IN REGLST) THEN BEGIN
IF (J←J+1)=1 THEN
PR!FIRST
ELSE PRINT(STR←SINDENT,DITTO,"OF ",PREG(OBJ,NMSW),
"IS ",CRLF);
END;
END;
[6] IF (OBJECT IN REGLST) THEN BEGIN
OBJ←OBJECT;
VAL←VALUE;
FOREACH PRO|PRO⊗OBJ≡VAL DO
IF (J←J+1)=1 THEN
PR!FIRST
ELSE PRINT(STR←SINDENT,PPROP(PRO),CRLF);
END ;
[7] IF (OBJECT IN REGLST) THEN
PRINT(SINDENT,PPROP(PROPERTY),"OF ",PREG(OBJECT,NMSW),"IS ",
PRIN!MODIF,PVAL(PROPERTY,VALUE,NMSW),CRLF)
END;
END "PASREG";
! PROCEDURE RETURN ALL THE PROPERTIES OF A REGION.
NOTE: AT PRESENT IT DOESN'T GIVE THE VECTOR LIST.
FOR RESULTS OF NMSW VALUES, SEE PREG;
simple INTERNAL PROCEDURE PREGION(STRING ITEMVAR REG;REFERENCE LIST REGLST;INTEGER NMSW);
BEGIN "PREGION"
ITEMVAR PROPERTY,ZILCHVAR;
PRINT("[",PROPS(REG),"] ",DATUM(REG),CRLF);
FOREACH PROPERTY | PROPERTY IN DPROLST DO
PASREG(PROPERTY,REG,ZILCHVAR,REGLST,4,NMSW,5);
END "PREGION";
REQUIRE UNSTACK!DELIMITERS;
END "PDTBAS";